home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 4 / Info_Mac IV CD-ROM (Pacific HiTech Inc.)(August 1994).iso / Development / General / ViewIt™ 2.24 Shareware / FORTRAN Demo Projects / Absoft MacFortran II 3.2 Demos / FaceProcAF.inc next >
Text File  |  1993-09-21  |  3KB  |  87 lines
  1. C FaceWare 2.2 Initialization & Dispatching Procedures
  2. C ©FaceWare 1989-93.  All Rights Reserved.
  3.  
  4.     SUBROUTINE FaceIt(xPtr,m1,m2,m3,m4,m5)
  5.     implicit none
  6.     integer*4 JumpIt
  7.     inline (JumpIt = /z'2257',z'2051',z'4e90'/)
  8.     integer*4 xPtr,m1,m2,m3,m4,m5,i,restype,thePtr,fPtr
  9.       record /FaceRec/ fRec
  10.       common/FaceStuff/fRec
  11.     thePtr = xPtr
  12.     fPtr = %loc(fRec)
  13.     if (m1 == -61) then
  14.       if ((m4 > -1).and.((m4.and.1) == 0)) then
  15.         call FlushEvents(%val2(62),%val2(0)) !ignore spurious mouse & key events
  16.       end if
  17.       fRec.uName = char(len(trim(fRec.uName)))//fRec.uName
  18.       restype = z'46434D44' != "FCMD", find LoadIt or quit to Finder
  19.       if (GetResource(%val4(restype),%val2(1000)) == 0) then
  20.         if (OpenResFile(fRec.uName) < 0) stop
  21.       end if
  22.       fRec.fFlags = m2         !store FaceIt bit flags
  23.       fRec.xEntries = m5         !store # of table entries
  24.       thePtr = fPtr
  25.       if (m3 > -1) then           !call LoadIt to expand heap?
  26.         call PrepIt(thePtr,m3,0,0,thePtr)
  27.         call JumpIt(%val4(thePtr))
  28.       end if
  29.       call PrepIt(thePtr,1100,22,0,thePtr)      !setup fRec header
  30.       call PrepIt(thePtr+1002,1210,22,0,thePtr) !setup uRec header
  31.       call PrepIt(thePtr+1634,1200,22,0,thePtr) !setup vRec header
  32.       fRec.fHead(6) = m4           !store environment type
  33.       fRec.uHead(6) = 2            !establish string type
  34.       thePtr = 0
  35.       if (m4 < -3) return
  36.     end if
  37.     if (m1 == -62) then
  38.       call PrepIt(m2,m3,m4,m5,fPtr)
  39.     else if ((m1 < 0).and.(m1 > -11)) then
  40.       i = (4 * (-1 - m1))
  41.       fRec.xTable(1+i) = m2
  42.       fRec.xTable(2+i) = m3
  43.       fRec.xTable(3+i) = m4
  44.       fRec.xTable(4+i) = m5
  45.     else
  46.       if (thePtr == 0) then      !call to default module?
  47.         thePtr = fPtr + 1002
  48.       else if (long(thePtr + 12) <> fPtr) then
  49.         fRec.cControl = thePtr   !call to control driver?
  50.         thePtr = fPtr + 1634
  51.       end if
  52.       word(thePtr + 8) = 0
  53.       fRec.uCommand = m1         !pass Command & Params
  54.       fRec.uParam(1) = m2
  55.       fRec.uParam(2) = m3
  56.       fRec.uParam(3) = m4
  57.       fRec.uParam(4) = m5
  58.       call JumpIt(%val4(thePtr)) !jump to FCMD module
  59.     end if
  60.     end
  61.  
  62.     SUBROUTINE PrepIt(x,b,v,r,f)
  63.     implicit none
  64.     integer*4 x,b,v,r,f,i,restype,resptr
  65.       record /FaceRec/ fRec
  66.       common/FaceStuff/fRec
  67.     restype = z'46434D44' != "FCMD"
  68.     resptr = long(GetResource(%val4(restype),%val2(1000)))
  69.     long(x) = resptr
  70.     word(x+4) = b    !baseID
  71.     word(x+6) = v    !versID
  72.     word(x+8) = 0    !message
  73.     word(x+10) = r    !resID
  74.     long(x+12) = f    !fPtr
  75.     if (fRec.xEntries > 0) then
  76.      do (i = 0, fRec.xEntries-1)
  77.       if (b == fRec.xTable(1 + 4*i)) then
  78.        if (v == fRec.xTable(2 + 4*i)) then
  79.         if (0 <> fRec.xTable(4 + 4*i)) then
  80.          long(x) = fRec.xTable(4 + 4*i)
  81.         end if
  82.        end if
  83.       end if
  84.      end do
  85.     end if
  86.     end
  87.